home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scheme2c.init < prev    next >
Text File  |  1999-04-19  |  9KB  |  296 lines
  1. ;;; "scheme2c.init" Initialisation for SLIB for Scheme->C on Sun -*-scheme-*-
  2. ;;; Authors: David Love and Aubrey Jaffer
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;Modified by David Love (d.love@daresbury.ac.uk) 10/12/91
  7. ;; NB this is for the 01nov91 (and, presumably, later ones,
  8. ;; although those may not need the bug fixes done at the end).
  9. ;; Earlier versions definitely aren't rev4 conformant.  Check
  10. ;; `ieee-floating-point' and `system' in *features* for non-Sun un*x
  11. ;; versions and `system' and the vicinity stuff (at least) for
  12. ;; non-un*x versions.
  13.  
  14. ;; Of course, if you make serious use of library functions you'll want
  15. ;; to compile them and  use Scheme->C modules.
  16.  
  17. (define (software-type) 'UNIX)
  18.  
  19. ;;; (scheme-implementation-type) should return the name of the scheme
  20. ;;; implementation loading this file.
  21.  
  22. (define (scheme-implementation-type) 'Scheme->C)
  23.  
  24. ;;; (scheme-implementation-home-page) should return a (string) URL
  25. ;;; (Uniform Resource Locator) for this scheme implementation's home
  26. ;;; page; or false if there isn't one.
  27.  
  28. (define (scheme-implementation-home-page) #f)
  29.  
  30. ;;; (scheme-implementation-version) should return a string describing
  31. ;;; the version the scheme implementation loading this file.
  32.  
  33. (define (scheme-implementation-version) "?01nov91")
  34.  
  35. (define (implementation-vicinity)
  36.   (case (software-type)
  37.     ((UNIX)    "/usr/local/lib/scheme/")
  38.     ((VMS)    "scheme$src:")
  39.     ((MS-DOS)    "C:\\scheme\\")))
  40.  
  41. ;;; (library-vicinity) should be defined to be the pathname of the
  42. ;;; directory where files of Scheme library functions reside.
  43.  
  44. (define library-vicinity
  45.   (let ((library-path
  46.      (case (software-type)
  47.        ((UNIX) "/usr/local/lib/slib/")
  48.        ((VMS) "lib$scheme:")
  49.        ((MS-DOS) "C:\\SLIB\\")
  50.        (else ""))))
  51.     (lambda () library-path)))
  52.  
  53. ;;; (home-vicinity) should return the vicinity of the user's HOME
  54. ;;; directory, the directory which typically contains files which
  55. ;;; customize a computer environment for a user.
  56.  
  57. (define home-vicinity
  58.   (let ((home-path (getenv "HOME")))
  59.     (lambda () home-path)))
  60.  
  61. ;;; *FEATURES* should be set to a list of symbols describing features
  62. ;;; of this implementation.  See Template.scm for the list of feature
  63. ;;; names.
  64.  
  65. (define *features*
  66.       '(
  67.     source                ;can load scheme source files
  68.                     ;(slib:load-source "filename")
  69. ;    compiled            ;can load compiled files
  70.                     ;(slib:load-compiled "filename")
  71.     rev4-report
  72.     ;; Follows rev4 as far as I can tell, modulo '() being false,
  73.     ;; number syntax (see doc), incomplete tail recursion (see
  74.     ;; docs) and a couple of bugs in some versions -- see below.
  75.     rev3-report            ;conforms to
  76. ;    ieee-p1178            ;conforms to
  77.     ;; ieee conformance is ruled out by '() being false, if
  78.     ;; nothing else.
  79.     rev4-optional-procedures
  80.     rev3-procedures
  81. ;    rev2-procedures
  82.     multiarg/and-
  83.     multiarg-apply
  84.     rationalize
  85.     object-hash
  86.     delay
  87.     promise
  88.     with-file
  89.     transcript
  90.     char-ready?
  91.     ieee-floating-point
  92.     full-continuation
  93.     pretty-print
  94.     format
  95.     trace                ;has macros: TRACE and UNTRACE
  96.     string-port
  97.     system
  98.     ;; next two could be added easily to the interpreter
  99. ;    getenv
  100. ;    program-arguments
  101.     ))
  102.  
  103. (define pretty-print pp)
  104.  
  105. ;;; (OUTPUT-PORT-WIDTH <port>)
  106. (define (output-port-width . arg) 79)
  107.  
  108. ;;; (OUTPUT-PORT-HEIGHT <port>)
  109. (define (output-port-height . arg) 24)
  110.  
  111. ;;; (CURRENT-ERROR-PORT)
  112. (define current-error-port
  113.   (let ((port (current-output-port)))
  114.     (lambda () port)))
  115.  
  116. ;;; (TMPNAM) makes a temporary file name.
  117. (define tmpnam
  118.   (let ((cntr 100))
  119.     (lambda () (set! cntr (+ 1 cntr))
  120.         (let ((tmp (string-append "slib_" (number->string cntr))))
  121.           (if (file-exists? tmp) (tmpnam) tmp)))))
  122.  
  123. ;;; (FILE-EXISTS? <string>)
  124. (define (file-exists? f)
  125.   (case (software-type)
  126.     ((UNIX) (zero? (system (string-append "test -f " f))))
  127.     (else (slib:error "FILE-EXISTS? not defined for " software-type))))
  128.  
  129. ;;; (DELETE-FILE <string>)
  130. (define (delete-file f)
  131.   (case (software-type)
  132.     ((UNIX) (zero? (system (string-append "rm " f))))
  133.     (else (slib:error "DELETE-FILE not defined for " software-type))))
  134.  
  135. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  136. ;;; use this definition if your system doesn't have such a procedure.
  137. (define force-output flush-buffer)
  138.  
  139. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  140. ;;; port versions of CALL-WITH-*PUT-FILE.
  141. (define (call-with-output-string f)
  142.   (let ((outsp (open-output-string)))
  143.     (f outsp)
  144.     (let ((s (get-output-string outsp)))
  145. ;;;   (close-output-port outsp)        ;doesn't work
  146.       s)))
  147.  
  148. (define (call-with-input-string s f)
  149.   (let* ((insp (open-input-string s))
  150.      (res (f insp)))
  151.     (close-input-port insp)
  152.     res))
  153.  
  154. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  155. ;;; be returned by CHAR->INTEGER.
  156. (define char-code-limit 256)
  157.  
  158. ;; MOST-POSITIVE-FIXNUM is used in modular.scm
  159. (define most-positive-fixnum 536870911)
  160.  
  161. ;;; Return argument
  162. (define (identity x) x)
  163.  
  164. ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
  165. (define slib:eval eval)
  166.  
  167. (define-macro defmacro
  168.   (lambda (f e)
  169.     (let ((key (cadr f)) (pattern (caddr f)) (body (cdddr f)))
  170.       (e `(define-macro ,key 
  171.         (let ((%transformer (lambda ,pattern ,@body)))
  172.           (lambda (%form %expr)
  173.         (%expr (apply %transformer (cdr %form)) %expr))))
  174.      e))))
  175.  
  176. (define (defmacro? m) (and (getprop m '*expander*) #t))
  177.  
  178. (define macroexpand-1 expand-once)
  179.  
  180. (define (macroexpand e)
  181.   (if (pair? e) (let ((a (car e)))
  182.           (if (and (symbol? a) (getprop a '*expander*))
  183.               (macroexpand (expand-once e))
  184.               e))
  185.       e))
  186.  
  187. (define gentemp
  188.   (let ((*gensym-counter* -1))
  189.     (lambda ()
  190.       (set! *gensym-counter* (+ *gensym-counter* 1))
  191.       (string->symbol
  192.        (string-append "slib:G" (number->string *gensym-counter*))))))
  193.  
  194. (define defmacro:eval slib:eval)
  195. (define defmacro:load load)
  196. ;;; If your implementation provides R4RS macros:
  197. ;(define macro:eval slib:eval)
  198. ;(define macro:load load)
  199.  
  200. (define (slib:eval-load <pathname> evl)
  201.   (if (not (file-exists? <pathname>))
  202.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  203.   (call-with-input-file <pathname>
  204.     (lambda (port)
  205.       (let ((old-load-pathname *load-pathname*))
  206.     (set! *load-pathname* <pathname>)
  207.     (do ((o (read port) (read port)))
  208.         ((eof-object? o))
  209.       (evl o))
  210.     (set! *load-pathname* old-load-pathname)))))
  211.  
  212. (define slib:warn
  213.   (lambda args
  214.     (let ((port (current-error-port)))
  215.       (display "Warn: " port)
  216.       (for-each (lambda (x) (display x port)) args))))
  217.  
  218. ;; define an error procedure for the library
  219. (define (slib:error . args)
  220.   (error 'slib-error: "~a"
  221.      (apply string-append
  222.         (map
  223.          (lambda (a)
  224.            (format " ~a" a))
  225.          args))))
  226.  
  227. ;; define these as appropriate for your system.
  228. (define slib:tab (integer->char 9))
  229. (define slib:form-feed (integer->char 12))
  230.  
  231. ;;; bug fixes for Scheme->C (versions 28sep90, 23feb90, 01nov91):
  232.  
  233. (let ((vers (substring (cadr (implementation-information)) 0 7)))
  234.   (if (or (string=? vers "28sep90") (string=? vers "23feb90")
  235.       (string=? vers "01nov91"))
  236.       (begin
  237.     ;; GCD fails with 0 as argument
  238.     (define old-gcd gcd)
  239.     (set! gcd (lambda args
  240.             (apply old-gcd (remv! 0 args))))
  241.     
  242.     ;; STRING->SYMBOL doesn't allocate a new string
  243.     (set! string->symbol
  244.           (let ((fred string->symbol))
  245.         (lambda (a) (fred (string-append a)))))
  246.     
  247.     ;; NUMBER->STRING can generate a leading #?
  248.     (set! number->string
  249.           (let ((fred number->string))
  250.         (lambda (num . radix)
  251.           (let ((joe (apply fred num radix)))
  252.             (if (char=? #\# (string-ref joe 0))
  253.             (substring joe 2 (string-length joe))
  254.             joe)))))
  255.     
  256.     ;; Another bug is bad expansion of LETREC when the body starts with a
  257.     ;; DEFINE as shown by test.scm -- not fixed here.
  258.     )))
  259.  
  260. (define promise:force force)
  261.  
  262. ;;; (implementation-vicinity) should be defined to be the pathname of
  263. ;;; the directory where any auxillary files to your Scheme
  264. ;;; implementation reside.
  265.  
  266. (define in-vicinity string-append)
  267.  
  268. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  269. ;;; return if exitting not supported.
  270. (define slib:exit (lambda args (exit)))
  271.  
  272. ;;; Here for backward compatability
  273. (define scheme-file-suffix
  274.   (let ((suffix (case (software-type)
  275.           ((NOSVE) "_scm")
  276.           (else ".scm"))))
  277.     (lambda () suffix)))
  278.  
  279. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  280. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  281.  
  282. (define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
  283.  
  284. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  285. ;;; by compiling "foo.scm" if this implementation can compile files.
  286. ;;; See feature 'COMPILED.
  287.  
  288. (define slib:load-compiled load)
  289.  
  290. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  291.  
  292. (define slib:load slib:load-source)
  293.  
  294. (slib:load (in-vicinity (library-vicinity) "require"))
  295. ; eof
  296.